home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / beta.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  6KB  |  182 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. (defun beta (tree env)
  4.   (unless (null tree)
  5.     (typecase tree
  6.       (seq (beta-seq tree env))
  7.       (scope-control-transfer (beta-scope-control-transfer tree env))
  8.       (unwind-protect (beta-unwind-protect tree env))
  9.       (var-ref (beta-var-ref tree env))
  10.       (var-def (beta-var-def tree env))
  11.       (mvalues (beta-values tree env))
  12.       (if (beta-if tree env))
  13.       (switch (beta-switch tree env))
  14.       (function-call (beta-function-call tree env))
  15.       (control-point (beta-control-point tree env))
  16.       (t tree))))
  17.  
  18. (defun beta-list (l env)
  19.   (loop for rest on l
  20.     do (setf (car rest) (beta (car rest) env))
  21.     finally (return l)))
  22.  
  23. (defun beta-body (body env)
  24.   (if (atom body)
  25.       (beta body env)
  26.       (beta-list body env)))
  27.  
  28. (defun beta-seq (tree env)
  29.   (typecase tree
  30.     (named-local (beta-named-local tree env))
  31.     (progn (beta-progn tree env))
  32.     (t (when (values-seq-p tree)
  33.      (beta-list (values-seq-values tree) env))
  34.        (when (scope-seq-p tree)
  35.      (setf (scope-seq-control-point tree)
  36.            (beta (scope-seq-control-point tree) env)))
  37.        (setf (seq-body tree) (beta-body (seq-body tree) env))
  38.        tree)))
  39.  
  40. (defun beta-progn (tree env)
  41.   (let ((beta-body (beta-body (seq-body tree) env)))
  42.     (cond ((atom beta-body) beta-body)
  43.       ((= (length beta-body) 1) (car beta-body))
  44.       (t (setf (seq-body tree) beta-body)
  45.          tree))))
  46.  
  47. (defun beta-named-local (tree env)
  48.   (let ((vars (named-local-vars tree))
  49.     (values (beta-list (named-local-values tree) env))
  50.     (body (seq-body tree)))
  51.     (multiple-value-bind (new-vars new-vals new-env)
  52.     (collect-beta-pairs vars values nil nil env)
  53.       (if (null new-vars)
  54.       (let ((beta-body (beta body (acons (first (named-local-vars tree))
  55.                          (first values)
  56.                          new-env))))
  57.         (setf (code-out-type beta-body) (code-out-type tree))
  58.         tree)
  59.       (progn (setf (named-local-vars tree) new-vars)
  60.          (setf (named-local-values tree) new-vals)
  61.          (setf (seq-body tree) (beta-body body new-env))
  62.          tree)))))
  63.  
  64. (defun collect-beta-pairs (orig-vars orig-vals new-vars new-vals env)
  65.   (if (null orig-vars)
  66.       (values (nreverse new-vars) (nreverse new-vals) env)
  67.       (let ((var (car orig-vars))
  68.         (val (car orig-vals)))
  69.     (unless (null val)        ; HEY! How can this be null???
  70.       (propagate-out-type var val))
  71.     (if (and (beta-value? val)
  72.          (variable-var-p var)    ; avoid fvar subst for now...
  73.          ;; More than one subst means we need to increment
  74.          ;; the tmp var count.
  75.          ;; also need to keep part of the orig so
  76.          ;; that attributes like tail?, etc. are distinct
  77.          ;; for each occurence.
  78.          (<= (var-num-refs var) 1)
  79.          (= (var-num-defs var) 0)
  80.          ;; Don't try to subst through closure boundries
  81.          (eq (var-extent var) :dynamic))
  82.         (collect-beta-pairs (cdr orig-vars)
  83.                 (cdr orig-vals)
  84.                 new-vars
  85.                      new-vals
  86.                 (acons var val env))
  87.         (collect-beta-pairs (cdr orig-vars)
  88.                 (cdr orig-vals)
  89.                 (cons var new-vars)
  90.                 (cons val new-vals)
  91.                 env)))))
  92.  
  93. (defun propagate-out-type (var val)
  94.   (let ((var-type (var-definite-type var))
  95.     (val-type (code-out-type val)))
  96.     (when (and (= (var-num-defs var) 0)
  97.            (eq var-type t))
  98.       (setf (var-definite-type var) val-type))))
  99.  
  100. (defun beta-value? (val)
  101.   (or (constant-p val)
  102.       (and (var-ref-p val)
  103.        (= (var-num-defs (var-ref-var val)) 0))))
  104. #|
  105.       ;; OOPS! Consider this LETF expansion:
  106.       ;;((LAMBDA (OLD-VALUE-2652)
  107.       ;;         (UNWIND-PROTECT (PROGN (SETF (CAR A) X)
  108.       ;;                                (PRINT A))
  109.       ;;                         (SETF (CAR A) OLD-VALUE-2652)))
  110.       ;;  (CAR A))
  111.       ;; Disable primtive call subst until we can be careful enough
  112.       ;; to avoid doing the beta-subst in the code above.
  113.       (and (primitive-call-p val)
  114.        (dolist (arg (primitive-call-args val) t)
  115.          (unless (beta-value? arg) (return nil))))
  116. |#
  117.  
  118. (defun beta-values (tree env)
  119.   (beta-list (mvalues-args tree) env)
  120.   tree)
  121.  
  122. (defun beta-var-ref (tree env)
  123.   ;; Update out-type of ref in case we found out new info about var type.
  124.   (setf (code-out-type tree) (var-definite-type (var-ref-var tree)))
  125.   (let ((entry (assoc (var-ref-var tree) env :test #'eq)))
  126.     (if (null entry)
  127.     tree
  128.     (let ((new (cdr entry)))
  129.       (setf (code-tail? new) (code-tail? tree))
  130.       (merge-out-type new (code-out-type tree))
  131.       new))))
  132.  
  133. (defun beta-var-def (tree env)
  134.   (setf (var-def-value tree) (beta (var-def-value tree) env))
  135.   tree)
  136.  
  137. (defun beta-function-call (tree env)
  138.   (when (unnamed-call-p tree)
  139.     (setf (unnamed-call-function-form tree)
  140.       (beta (unnamed-call-function-form tree) env)))
  141.   (beta-list (function-call-args tree) env)
  142.   tree)
  143.  
  144. (defun beta-if (tree env)
  145.   (setf (if-test tree) (beta (if-test tree) env))
  146.   (setf (if-then tree) (beta (if-then tree) env))
  147.   (setf (if-else tree) (beta (if-else tree) env))
  148.   tree)
  149.  
  150. (defun beta-switch (tree env)
  151.   (setf (branch-test tree) (beta (branch-test tree) env))
  152.   (setf (switch-consequents tree) (beta-list (switch-consequents tree) env))
  153.   (setf (switch-default tree) (beta (switch-default tree) env))
  154.   tree)
  155.  
  156. (defun beta-scope-control-transfer (tree env)
  157.   (setf (scope-control-transfer-send-value tree)
  158.     (beta (scope-control-transfer-send-value tree) env))
  159.   (setf (scope-control-transfer-destination-point tree)
  160.     (beta (scope-control-transfer-destination-point tree) env))
  161.   tree)
  162.  
  163. (defun beta-control-point (tree env)
  164.   (typecase tree
  165.     (dynamic-scope-control-point
  166.        (setf (dynamic-scope-control-point-tag-name tree)
  167.          (beta (dynamic-scope-control-point-tag-name tree) env)))
  168.     (dynamic-tag-control-point
  169.      (setf (dynamic-tag-control-point-tag-name tree)
  170.        (beta (dynamic-tag-control-point-tag-name tree) env))))
  171.   tree)
  172.  
  173. (defun beta-unwind-protect (tree env)
  174.   (setf (unwind-protect-cleanup-form tree)
  175.     (beta (unwind-protect-cleanup-form tree) env))
  176.   (setf (unwind-protect-protected-form tree)
  177.     (beta (unwind-protect-protected-form tree) env))
  178.   tree)
  179.  
  180.  
  181.  
  182.